home *** CD-ROM | disk | FTP | other *** search
/ Amiga Plus 2000 #5 / Amiga Plus CD - 2000 - No. 5.iso / Tools / Dev / fpc / demos / easygadtools.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2000-01-01  |  4.8 KB  |  179 lines
  1. PROGRAM EasyGadtools;
  2.  
  3. {
  4.     This is just a test on how to make a unit EasyGadtools.
  5.  
  6.     Feel free to make any changes or improvements on this
  7.     example. If you make a unit or have a unit to handle
  8.     gadtools in an easy way let me know.
  9.  
  10.     24 Jul 2000.
  11.  
  12.     nils.sjoholm@mailbox.swipnet.se
  13.  
  14. }
  15.  
  16. USES Intuition, Exec, Graphics, GadTools, Utility, vartags,pastoc;
  17.  
  18. CONST
  19.  
  20.      strarray : array[0..4] of PChar = ('A cycle',
  21.                                         'test',
  22.                                         'for',
  23.                                         'FPC Pascal',
  24.                                         nil);
  25.                                 
  26.                                    
  27. VAR
  28.   ps                : pScreen;
  29.   vi                : Pointer;
  30.   ng                : tNewGadget;
  31.   glist,gad         : pGadget;
  32.   wp                : pWindow;
  33.   HFont             : word;
  34.   HGadget           : word;
  35.   DistGad           : word;
  36.   HG                : word;
  37.   attr              : pTextAttr;
  38.  
  39. function NewGadget(left,top,width,height : Integer; txt : PChar; txtattr: pTextAttr;
  40.                    id : word; flags: Longint; visinfo, userdata : Pointer): tNewGadget;
  41. var
  42.     ng : tNewGadget;
  43. begin
  44.     with ng do begin
  45.         ng_LeftEdge   := left;
  46.         ng_TopEdge    := top;
  47.         ng_Width      := width;
  48.         ng_Height     := height;
  49.         ng_GadgetText := txt;
  50.         ng_TextAttr   := txtattr;
  51.         ng_GadgetID   := id;
  52.         ng_Flags      := flags;
  53.         ng_VisualInfo := visinfo;
  54.         ng_UserData   := userdata;
  55.     END;
  56.     NewGadget := ng;
  57. end;
  58.  
  59. PROCEDURE CleanUp(why : string; rc : BYTE);
  60. BEGIN
  61.   IF assigned(wp) THEN CloseWindow(wp);
  62.   IF assigned(glist) THEN FreeGadgets(glist);
  63.   IF assigned(vi) THEN FreeVisualInfo(vi);
  64.   if why <> '' then writeln(why);
  65.   HALT(rc);
  66. END;
  67.  
  68. { Clones some datas from default pubscreen for fontsensitive
  69.   placing of gadgets. }
  70. PROCEDURE CloneDatas;
  71. BEGIN
  72.   ps := LockPubScreen(NIL);
  73.   IF ps = NIL THEN CleanUp('Can''t get a lock on public screen',20)
  74.   ELSE
  75.   BEGIN
  76.      HFont := ps^.Font^.ta_YSize;
  77.      attr := ps^.Font;
  78.      vi := GetVisualInfoA(ps,NIL);
  79.      UnLockPubScreen(NIL, ps);
  80.      IF vi = NIL THEN CleanUp('Can''t get VisualInfo', 20);
  81.   END;
  82. END;
  83.  
  84. function ButtonGadget(id,left,top,width,height:word; txt:pchar): pGadget;
  85. begin
  86.    ng := NewGadget(left,top,width,height,txt,attr,id,PLACETEXT_IN,vi,nil);
  87.    gad := CreateGadgetA(BUTTON_KIND,gad,@ng,nil);
  88.    ButtonGadget := gad;
  89. end;
  90.  
  91. function ButtonGadget(id,left,top,width,height:word; txt: string): pGadget;
  92. begin
  93.    ButtonGadget := ButtonGadget(id,left,top,width,height,pas2c(txt));
  94. end;
  95.  
  96. function CycleGadget(id,left,top,width,height:word; txt:pchar ; thearr : Pointer): pGadget;
  97. begin
  98.    ng := NewGadget(left,top,width,height,txt,attr,id,PLACETEXT_LEFT,vi,nil);
  99.    gad := CreateGadgetA(CYCLE_KIND,gad,@ng,TAGS(
  100.                                          GTCY_Labels,long(thearr),
  101.                                          TAG_END));
  102.    CycleGadget := gad;
  103. end;
  104.  
  105. PROCEDURE GenerateWindow;
  106. BEGIN
  107.   glist := NIL; gad := CreateContext(addr(glist));
  108.   IF gad = NIL THEN CleanUp('Can''t create GadList', 20);
  109.  
  110.   gad := ButtonGadget(0,10,HG,200,HGadget,'File Requester');
  111.   HG := HG + DistGad;
  112.  
  113.   gad := ButtonGadget(1,10,HG,200,HGadget,'Font Requester');
  114.   HG := HG + DistGad;
  115.  
  116.   gad := ButtonGadget(2,10,HG,200,HGadget,'Screen Requester');
  117.   HG := HG + DistGad + 3;
  118.  
  119.   gad := CycleGadget(3,100,HG,100,HGadget,'Cycle me',@strarray);
  120.   HG := HG + DistGad+4;
  121.  
  122.   gad := ButtonGadget(4,10,HG,96,HGadget,'OK');
  123.   gad := ButtonGadget(5,115,HG,96,HGadget,'Cancel');
  124.  
  125.   HG := HG + 5;
  126.  
  127.   if gad = nil then CleanUp('Can''t create gadgets',20);
  128.  
  129.   wp := OpenWindowTagList(NIL,TAGS(
  130.                 WA_Gadgets, LONG(glist),
  131.                 WA_Title, longstr('Test of EasyGadtools'),
  132.                 WA_Left,100,
  133.                 WA_Top,100,
  134.                 WA_Flags, WFLG_SMART_REFRESH OR WFLG_NOCAREREFRESH OR
  135.                                 WFLG_DEPTHGADGET OR WFLG_DRAGBAR OR WFLG_CLOSEGADGET OR
  136.                                 WFLG_ACTIVATE,
  137.                 WA_Idcmp, IDCMP_GADGETUP OR IDCMP_CLOSEWINDOW,
  138.                 WA_InnerWidth, 215,
  139.                 WA_InnerHeight, HG,
  140.                 TAG_DONE));
  141.   
  142.   IF wp = NIL THEN CleanUp('Can''t open window', 20);
  143. END;
  144.  
  145. PROCEDURE MainWait;
  146. VAR
  147.   msg : pIntuiMessage;
  148.   iclass : LONG;
  149.   ende : BOOLEAN;
  150. BEGIN
  151.   ende := FALSE;
  152.   REPEAT
  153.     msg := pIntuiMessage(WaitPort(wp^.UserPort));
  154.      msg := GT_GetIMsg(wp^.UserPort);
  155.      WHILE msg <> NIL DO
  156.      BEGIN
  157.         iclass := msg^.IClass;
  158.         GT_ReplyIMsg(msg);
  159.         CASE iclass OF
  160.           IDCMP_CLOSEWINDOW : ende := TRUE;
  161.           IDCMP_GADGETUP : writeln('You clicked on a gadget');
  162.         ELSE END;
  163.        msg := GT_GetIMsg(wp^.UserPort);
  164.      END;
  165.   UNTIL ende;
  166. END;
  167.  
  168. BEGIN
  169.   CloneDatas;
  170.   HGadget := HFont +6;
  171.   DistGad := HGadget +4;
  172.   HG := HFont + 10;
  173.   GenerateWindow;
  174.   MainWait;
  175.   CleanUp('',0);
  176. END.
  177.  
  178.  
  179.